Only Forth Definitions

\ Allocate a memory buffer and automatically free it when the routine returns.
:[] temp:[
  swap allocate drop dup >q
  swap catch
  q> free drop
  throw ;

:[] <>:[   ( n addr xt -- )  ( n -- )
   >q 2dup @ <> if over swap ! q> execute else 2drop q> drop then ;

type: vertexdef
   delegate glarrays
   delegate vertex
   delegate 2vertex
end-type


variable last-vertex-array
variable last-tcoord-array
variable last-color-array

0 Value vcolor
0 Value tcoord-x
0 Value tcoord-y
0 Value vpointer
0 Value stride


\ ----------------------------------------
\ GL

variable last-matrix
variable gl-blend GL_BLEND ,
variable gl-alpha GL_ALPHA ,
variable gl-alphatest GL_ALPHA_TEST ,
variable gl-depthtest GL_DEPTH_TEST ,
variable last-depthfunc
variable last-depthmask
variable last-alphafunc
variable last-blendfunc
variable last-texture
variable gl-texture GL_TEXTURE_2D ,
variable gl-vertex-array GL_VERTEX_ARRAY ,
variable gl-texture-array GL_TEXTURE_COORD_ARRAY ,
variable gl-color-array GL_COLOR_ARRAY ,
variable gl-normal-array GL_NORMAL_ARRAY ,
variable last-vbo
0 value texture-filter \ defines the filtering to use for new textures ( GL_NEAREST, GL_LINEAR )
   GL_NEAREST to texture-filter



GL_PROJECTION constant projection
GL_MODELVIEW constant modelview
GL_TEXTURE constant texture-matrix

0 value 2dmode?

: matrix   last-matrix <>:[ glMatrixMode ;] ;
: identity   glLoadIdentity ;
: pm-identity    projection matrix identity ;
: mv-identity   modelview matrix identity ( 2dmode? if 0.001e 0.001e 0e  glTranslatef  then ) ;
: tm-identity    texture-matrix matrix identity ;

: push-modelview   modelview matrix glPushMatrix ;
: pop-modelview   modelview matrix glPopMatrix ;
: push-texmtx   texture-matrix matrix glPushMatrix ;
: pop-texmtx  texture-matrix matrix glPopMatrix ;

: gl-enable   dup cell+ @ locals| flag | GL_TRUE swap <>:[ drop glEnable( flag ) ;] ;
: gl-disable   dup cell+ @ locals| flag | GL_FALSE swap <>:[ drop glDisable( flag ) ;] ;
: gl-enable-clientstate
   dup cell+ @ locals| flag | GL_TRUE swap <>:[ drop glEnableClientState( flag ) ;] ;
: gl-disable-clientstate
   dup cell+ @ locals| flag | GL_FALSE swap <>:[ drop glDisableClientState( flag ) ;] ;

: enable-translucency
  gl-alpha gl-enable
  gl-blend gl-enable ;

: disable-translucency
  gl-alpha gl-disable
  gl-blend gl-disable ;

: set-blendfunc   ( n -- ) last-blendfunc <>:[ execute glBlendFunc ;] ;
: set-alphafunc  ( xt -- ) last-alphafunc <>:[ execute glAlphaFunc ;] ;
: set-depthfunc   ( n -- ) last-depthfunc <>:[ glDepthFunc ;] ;

: bind-texture
   gl-texture gl-enable
   last-texture <>:[ GL_TEXTURE_2D swap glBindTexture ;] ;


: disable-depth-writing
  glDepthMask( GL_FALSE )  ;

: enable-depth-writing
  glDepthMask( GL_TRUE )  ;
{

: disable-depth-occlusion
  glDepthFunc( GL_ALWAYS ) ;
}

: new-vbo ( -- n )
  glGenBuffersARB( 1   pad  )   pad @ ;

: bind-vbo  ( vbo -- )
   last-vbo <>:[ glBindBufferARB( GL_ARRAY_BUFFER_ARB swap ) ;] ;

: unbind-vbo  ( -- )
   0 bind-vbo ;

: unmap-vbo ( -- )
   begin glUnmapBufferARB( GL_ARRAY_BUFFER_ARB ) until ;

: map-vbo ( size vbo -- addr )
   bind-vbo
   glBufferDataARB( GL_ARRAY_BUFFER_ARB swap   0   GL_STREAM_DRAW_ARB )
   glMapBufferARB( GL_ARRAY_BUFFER_ARB GL_WRITE_ONLY_ARB )  ;

: cls
   GL_COLOR_BUFFER_BIT GL_STENCIL_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT OR glClear ;

variable bgc
: clear-color
   bgc !
   glClearColor( bgc c@+ c>f c@+ c>f c@ c>f 1e ) ;

create tx 0 ,

: texture!filter
   glTexParameteri( GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER third )
   glTexParameteri( GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER rot ) ;

: new-texture ( -- texture )
   glGenTextures( 1  tx )
   tx @ dup bind-texture
   texture-filter texture!filter ;

: free-texture ( texture -- )
   tx !
   glDeleteTextures( 1  tx ) ;

: alphafunc[>0]   GL_GREATER 0e ;

:[] blendfunc:[  execute glBlendFunc ;
: set-default-blendfunc   blendfunc:[ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA ;] ;
: set-default-alphafunc   ['] alphafunc[>0] set-alphafunc ;
: set-default-depthfunc   GL_LEQUAL set-depthfunc ;

: reset-gl
   cr ." Reseting GLp.."
   last-matrix off
   gl-blend off        gl-blend gl-enable
   gl-alpha off        gl-alpha gl-enable
   gl-alphatest off    gl-alphatest gl-enable
   gl-depthtest on    gl-depthtest gl-disable
   last-depthfunc off  set-default-depthfunc
   last-alphafunc off  set-default-alphafunc
   last-blendfunc off  set-default-blendfunc
   last-texture on     0 bind-texture
   gl-texture on       gl-texture gl-disable
   last-vbo on         unbind-vbo
   glClearDepth( 1e )
   cls
   pm-identity
   tm-identity
   mv-identity
   glDepthFunc( GL_LEQUAL )
   glEnable( GL_DEPTH_TEST ) ;


\ ----------------------------------------
\ Vbuf

type: vbo   end-type

\ /Buffer Inherit
Node extend: vbuf
   vbo.pointer vb
   int.field vcount
   int.field ptype      \ GL primitive
   vertexdef.pointer vtype
end-type

node.make vbufs

0 vbo.ref mapped-vbo

: vbo.map  map-vbo ;
: vbo.unmap  unmap-vbo ;
: vbo.bind  bind-vbo ;
: vbo.unbind  unbind-vbo ;


method: vbuf.begin  ( count vbuf -- )
   vcount.!  vtype sizeof *  vb.map  to vpointer ;

: vbuf.end ( -- )
   vb.unbind ;



: (vertices)
   >r vbuf.begin r> execute vbuf.end ;

macro: vbuf.bind   ( vbuf -- )  vb.bind ;

: vbuf.init  ( vbuf -- )
   glGenBuffersARB( 1 &of swap.vb ) ;

\ -- Drawing --

method: vbuf.draw-some   ( index count vbuf -- )
   bind  0  vtype.glarrays
   ptype.@  -rot  glDrawArrays ;

method: vbuf.draw  ( vbuf -- )
   0 vcount.@ draw-some ;

\ -- Quotation words --

:[] vbuf.define:[   ( count vbuf xt -- )  ( -- )
   (vertices) ;

:[] vbuf.draw:[   ( count vbuf xt -- )  ( -- )
   over >q     (vertices)    q> draw  ;

\ -- Init --

: vbuf.make ( vertex-type gl-primitive  -- <name> )
   any.make   lastbody @ vbuf.<<   ptype.!  to vtype  >> ;

: init-vbufs
   vbufs.each:[ vbuf.init ;] ;

: bgra<>rgba
   dup 16 rshift $ff and   ( rgba b )
   over $ff and 16 lshift  ( rgba b 00r0 )
   rot $ff00ff00 and or or ;

: enable-vertex-array  (  -- )
   glEnableClientState( GL_VERTEX_ARRAY ) ;

: disable-vertex-array
   glDisableClientState( GL_VERTEX_ARRAY ) ;

: enable-color-array  (  -- )
\   >r 4 GL_UNSIGNED_BYTE stride r> glColorPointer
   glEnableClientState( GL_COLOR_ARRAY ) ;

: disable-color-array
   glDisableClientState( GL_COLOR_ARRAY ) ;

: enable-normal-array  (  -- )
\   GL_FLOAT stride rot glNormalPointer
   glEnableClientState( GL_NORMAL_ARRAY ) ;

: disable-normal-array
   glDisableClientState( GL_NORMAL_ARRAY ) ;

: enable-texture-array (  -- )
\   >r 2 GL_FLOAT stride r> glTexCoordPointer
   glEnableClientState( GL_TEXTURE_COORD_ARRAY ) ;

: disable-texture-array
   glDisableClientState( GL_TEXTURE_COORD_ARRAY ) ;

\ Enable/disable each of the arrays in one call.
\   texture, normal, color
: enable-TNC   ( flag flag flag -- )
   if enable-color-array else disable-color-array then
   if enable-normal-array else disable-normal-array then
   if enable-texture-array else disable-texture-array then ;

: draw-arrays2d  (  array  format  length  type -- )
   locals| type  length  format  array |
   glVertexPointer( 2  format  stride  array )
   enable-vertex-array
   gldrawarrays( type 0 length ) ;

: draw-arrays3d  (  array  format  length  type -- )
   locals| type  length  format  array |
   glVertexPointer(  3  format  stride  array )
   enable-vertex-array
   gldrawarrays( type 0 length ) ;

\ ----------------------------------------
\ Drawing API


macro: tcoord  to tcoord-y to tcoord-x ;
macro: +u   +to tcoord-x ;
macro: +v   +to tcoord-y ;

\ -----


vertexdef extend: vertex2d
   short.field x
   short.field y
   short.field z
   short.skip
   short.field u
   short.field v
   rgba32.field color
end-type

vertexdef extend: point2d
   short.field x
   short.field y
end-type

\ -- Vertex2D --
\  For textured and colored primitives.
\  Actually DOES support 3D but it's got a low 16-bit resolution; it's INTENDED for 2D.

method: vertex2d.glarrays ( addr/ofs -- )
   glEnableClientState( GL_VERTEX_ARRAY )
   glEnableClientState( GL_COLOR_ARRAY )
   glEnableClientState( GL_TEXTURE_COORD_ARRAY )
   glVertexPointer( 3 GL_SHORT  16  x )
   glTexCoordPointer( 2 GL_SHORT  16  u )
   glColorPointer( 4 GL_UNSIGNED_BYTE  16  color ) ;

' vertex2d.glarrays >delegate vertex2d glarrays

\ Follows pairing rules and uses inlining for best speed
icode vertex2d.vertex ( x y z -- )
  &of vpointer [u] eax mov
  0 [ebp] ecx mov
  16bit: ebx 4 [eax] mov    \ z
  4 [ebp] ebx mov
  16bit: ecx 2 [eax] mov    \ y
  16bit: ebx 0 [eax] mov    \ x

  &of tcoord-x [u] ecx mov
  &of tcoord-y [u] ebx mov
  &of vcolor [u] edx mov
  16bit: ecx 8 [eax] mov    \ u
  16bit: ebx 10 [eax] mov   \ v
  edx 12 [eax] mov          \ color

  2 cells [ebp] ebx mov
  16 # eax add
  3 cells # ebp add
  eax &of vpointer [u] mov
  ret end-code

' vertex2d.vertex >delegate vertex2d vertex


\ -- Point2d --
\  For solid 2D shapes

icode point2d.2vertex  ( x y -- )
  &of vpointer [u] eax mov
  0 [ebp] ecx mov
  16bit: ebx 2 [eax] mov    \ y
  16bit: ecx 0 [eax] mov    \ x
  1 cells [ebp] ebx mov
  4 # eax add
  2 cells # ebp add
  eax &of vpointer [u] mov
  ret end-code
' point2d.2vertex >delegate point2d 2vertex

: point2d.vertex
   drop point2d.2vertex ;
' point2d.vertex >delegate point2d vertex

: point2d.glarrays   ( addr/ofs -- )
   locals|  a/o  |
   glEnableClientState( GL_VERTEX_ARRAY )
   glDisableClientState( GL_COLOR_ARRAY )
   glDisableClientState( GL_TEXTURE_COORD_ARRAY )
   glVertexPointer( 2 GL_SHORT  4  a/o  ) ;
' point2d.glarrays >delegate point2d vertex


\ Populate a VBO with data of a given size.  Address of the buffer is placed in VPOINTER.
\  If the vbo can't be mapped to client mem, then the memory is allocated and copied after you populate it.
\  Creates a new buffer each time, which lets the old buffer finish rendering without blocking.
\  If the OpenGL driver can map the VBO to client mem, rendering speed is 15% faster on my machine.
\ DEPRECRATED
-? 0 value xt
-? 0 vbo.ref v
-? 0 value s
:[] vbo.varray:[  (  size vbo xt -- [ A=addr -- ]  )
   to xt to v to s
   s  v.map  ?dup 0=  if
      s temp:[ dup >q  to vpointer  xt catch   glBufferSubDataARB( GL_ARRAY_BUFFER_ARB   0   s   q> )  throw  ;]
   else
      to vpointer  xt catch vbo.unmap throw
   then ;

0 transform.ref t

: quad2d ( u1 v1 u2 v2 z x1 y1 x2 y2 vertexdef -- )
   locals| vd y2 x2 y1 x1 z v2 u2 v1 u1 |
      u1 v1 tcoord x1 y1 z vd vertex
      u1 v2 tcoord x1 y2 z vd vertex
      u2 v2 tcoord x2 y2 z vd vertex
      u2 v1 tcoord x2 y1 z vd vertex ;

: transformed-quad2d  ( u1 v1 u2 v2 z x1 y1 x2 y2 vertexdef transform -- )
   to t locals| vd y2 x2 y1 x1 z v2 u2 v1 u1 |
      u1 v1 tcoord x1 y1 t.2transform z vd vertex
      u1 v2 tcoord x1 y2 t.2transform z vd vertex
      u2 v2 tcoord x2 y2 t.2transform z vd vertex
      u2 v1 tcoord x2 y1 t.2transform z vd vertex ;


\ ----------------------------------------
\ Projection stuff

[undefined] 2dmode? [if] 0 value 2dmode? [then]

: aspect-ratio   screen-w s>p screen-h s>p p/ ;

: 3DMODE     pm-identity   glFrustum( aspect-ratio 10 / dup negate p>f swap p>f -0.1e 0.1e 0.1e 100e )  false to 2dmode?   mv-identity ;
\ : ORTHOMODE  pm-identity   glOrtho( aspect-ratio dup negate s>f swap s>f -1.0e 1.0e 0.1e 100e )  false to 2dmode?   mv-identity ;
\ : 2DMODE     pm-identity   glOrtho( 0e screen-w s>f screen-h s>f -0.45e f+ -0.45e  1024e -1024e )   true to 2dmode? mv-identity ;
: 2DMODE     pm-identity   glOrtho( -0.45e screen-w s>f -0.45e f+  screen-h s>f -0.45e f+ -0.45e  1024e -1024e )   true to 2dmode? mv-identity ;

\ ----------------------------------------
\ Display utilities

: fullscreen  true set-display ;
: window  false set-display ;
: display   fullscreen? set-display ;
